home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HPAVC
/
HPAVC CD-ROM.iso
/
PRUS101.ZIP
/
FSPEAKER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-12-19
|
25KB
|
1,016 lines
Unit FSpeaker; { FIDO unit: Handling of and sound effects for the PC speaker }
(***************************************************************************
RELEASE 1.04 - as first contained in the file PRUS101.LZH
by Orazio Czerwenka, 2:2450/540.55, GERMANY
--------------------------------------------
organized for Fido's PASCAL related echoes
--------------------------------------------
06/07/1994 to 07/04/1994 by Orazio Czerwenka, 2:2450/540.55, GERMANY
07/05/1994 to 07/15/1994 by Wolfram Sieber, 2:2453/90.6, GERMANY
07/16/1994 to --/--/---- by Orazio Czerwenka, 2:2450/540.55, GERMANY
====================================================================
Currently there is nobody who is interrested in further supporting
this unit as the 'unit's current organizer', even though there are
still some useful routines missing for those who excessivly want
to use PC speaker sounds in there own programs.
Probably Pawel Ostapczuk will take over this part for future
releases, but we don't know that definitely by now.
So if you've got yourself any more useful source you wish to
contribute to this unit or are interessted in becoming its new
'current organizer' send your sources or mails to the projects
'current' general supervisor:
--------------------------------------------
Orazio Czerwenka, 2:2450/540.55, GERMANY
--------------------------------------------
====================================================================
As far as third party copyrights are not violated this
source code is hereby placed to the public domain. Use
it whatever way you want, but use AT YOUR OWN RISK.
In case you should modify the source rather send your
modifications to the unit's current organizer (see above for
NM address) than to spread it on your own. This will help to
keep the unit updated and grant a certain standard to all
other users as well.
The unit is currently still under work. So it might greatly
benefit of your participation.
Those who contributed to the following piece of source,
listed in alphabethical order:
================================================================
Bill Buchanan, Christian Clemens, Orazio Czerwenka, Bjorn
Felten, Marcus Hardt, Mark Lewis, Max Maischein, Pawel
Ostapczuk, Peter Schuette, Wolfram Sieber, ...
================================================================
YOUR NAME WILL APPEAR HERE IF YOU CONTRIBUTE USEFUL SOURCE.
Special thanks to Max Maischein for his kind permission to
'exploit' his freeware collection of units 'SUX V. 1.0'.
Credits in your own programs are as welcome as unnecessary.
***************************************************************************)
{$I FDEFINE.DEF} { use the projects general conditional defines
and compiler directives ... }
{$R-} { ... and use the unit's specific defines
afterwards. }
Interface
Uses
{$IFDEF CRT}
CRT
{$ENDIF}
{$IFDEF FCRT}
{$IFDEF CRT} , {$ENDIF}
FCRT (* for hardware independent delay *)
{$ENDIF}
;
const
SoundsEnabled : boolean = TRUE; {read/write }
{ overloaded CRT routines: }
procedure nosound; { replaces CRT's nosound }
procedure sound (hertz : word); { replaces CRT's sound }
{ routines to save redunant code: }
Procedure SoundOff (DelayLen : Word); { Turns the sound off }
Procedure SoundOn (Note, Tone,
DelayLen : Word); { Turns the sound on }
{ parameterless routines: }
Procedure Alarm; { Gives an alarming sound }
Procedure Beep; { Makes a beep }
Procedure Bell; { Bright sound }
procedure Bell2; { 9 * BipSound }
procedure Bip; { 1050 Hz, 30 ms }
Procedure Boop; { Makes a boop }
procedure Bop; { 50 Hz, 30 ms }
Procedure BuzzSaw; { Makes a buzzsawing sound }
procedure Car;
procedure ClecClac;
Procedure CloseWhistle;
Procedure ErrorBeep; { Another 'deep' sounding error beep }
procedure Explosion;
procedure Explosion2;
Procedure Falling;
procedure Falling2;
Procedure Fanfare; { The FroDo BeBiBoop }
procedure Flak;
procedure Gun;
Procedure HiRing; { simulates a phone's 'high' ringing }
procedure Laser;
Procedure LoRing; { simulates a phone's 'low' ringing }
Procedure MorseCode; { Makes some senseless morse code }
procedure MP;
procedure Mystic;
procedure Mystic2;
procedure Mystic3;
procedure Mystic4;
procedure Mystic5;
procedure Noname1;
procedure Noname2;
procedure Noname3;
procedure Noname4;
procedure Noname5;
procedure Noname6;
procedure Nuke;
Procedure OpenWhistle;
procedure Rain;
procedure RandomSound;
procedure SinusBeep;
procedure StartingCar;
Procedure TootTootToot; {3 times: 444 Hz, 34 ms
0 Hz, 34 ms}
Procedure Warning;
Procedure WindowsBeep; { A rather crude windows - wrong -
key pressed - sound }
Procedure WrongSequence; { plays the 1st octave with swapped
'g' and 'a' }
Procedure Zip1; { Makes a sound like ZZZZip }
Procedure Zip2; { Makes a sound like ZZZZiiip }
{ routines with parameters: }
Procedure Beam (Heigth : Word); { Makes a 'beam' sound }
procedure Ploing (step : byte); { Makes a sawing noise. }
Procedure Zap (Key : Word); { Makes a sound like ZZZZaaap }
{----------------------------------------------------------------------------}
Implementation
{-overloaded CRT routines--------------------------------------------------1-}
procedure nosound; assembler;
{turns the speaker off}
{ Original author: Mark Lewis }
asm
IN AL,61h
AND AL,0FCh
OUT 61h,AL
end;
{ -------------------------------------------------------------------------- }
procedure sound (hertz : word); Assembler;
{hertz is the sound frequency to send to the speaker port}
{ Original author: Mark Lewis }
asm
MOV BX,SP
MOV BX,&hertz
MOV AX,34DDh
MOV DX,0012h
CMP DX,BX
JNB @J1
DIV BX
MOV BX,AX
IN AL,61h
TEST AL,03h
JNZ @J2
OR AL,03h
OUT 61h,AL
MOV AL,-4Ah
OUT 43h,AL
@J2:
MOV AL,BL
OUT 42h,AL
MOV AL,BH
OUT 42h,AL
@J1:
end;
{-overloaded CRT routines--------------------------------------------------9-}
{-routines to save redunant code-------------------------------------------1-}
Procedure SoundOff ( DelayLen : Word );
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Begin
NoSound;
If NOT SoundsEnabled then exit;
Delay( DelayLen );
End;
{ -------------------------------------------------------------------------- }
Procedure SoundOn ( Note, Tone, DelayLen : Word );
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Begin
If NOT SoundsEnabled then exit;
Sound( Note*Tone SHR 1 );
Delay( DelayLen );
End;
{-routines to save redunant code-------------------------------------------9-}
{-sound effects------------------------------------------------------------1-}
Procedure Alarm;
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Var I : Byte;
Begin
If NOT SoundsEnabled then exit;
For I := 1 To 3 Do
Begin
SoundOn ( 1000,2,300 );
SoundOn ( 500,1,300 );
End;
NoSound;
End;
{ -------------------------------------------------------------------------- }
Procedure Beam ( Heigth : Word );
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Var I : Word;
Begin
If NOT SoundsEnabled then exit;
For I := 1 To Heigth Do
Begin
SoundOn ( I * 10, 1, 5 );
SoundOff (5);
End;
For I := Heigth DownTo 1 Do
Begin
SoundOn ( I * 10, 1, 5 );
SoundOff (5);
End;
End;
{ -------------------------------------------------------------------------- }
Procedure Beep;
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Begin
If NOT SoundsEnabled then exit;
SoundOn (440,2,100);
NoSound;
End;
{ -------------------------------------------------------------------------- }
Procedure Bell;
{ Original author: Max Maischein }
Begin
If NOT SoundsEnabled then exit;
SoundOn (660,1,100);
NoSound;
End;
{ -------------------------------------------------------------------------- }
procedure Bell2;
{Original author: Wolfram Sieber}
const
BellDelay = 30;
var
i : byte;
begin
If NOT SoundsEnabled then exit;
for i:=1 to 9 do begin
Bip;
SoundOff (BellDelay)
end
END;
{ -------------------------------------------------------------------------- }
procedure Bip;
{Original author: Wolfram Sieber}
begin
If NOT SoundsEnabled then exit;
SoundOn (1050, 1, 30);
NoSound;
END;
{ -------------------------------------------------------------------------- }
Procedure Boop;
{ Original author: Max Maischein }
Begin
If NOT SoundsEnabled then exit;
SoundOn (220,2,100);
NoSound;
End;
{ -------------------------------------------------------------------------- }
procedure Bop;
{Original author: Wolfram Sieber}
begin
If NOT SoundsEnabled then exit;
SoundOn (50, 1, 30);
NoSound;
END;
{ -------------------------------------------------------------------------- }
Procedure BuzzSaw;
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Var I : Word;
Begin
If NOT SoundsEnabled then exit;
For I := 500 DownTo 1 Do
Begin
SoundOn ( I * 10, 1, 5 );
SoundOff (5);
End;
End;
{ -------------------------------------------------------------------------- }
procedure Car;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:=10 to 540 do
SoundOn (round(1000*sin(i * 1 div 2)), 1, 1);
nosound;
end;
{ -------------------------------------------------------------------------- }
procedure ClecClac;
{Original author: Wolfram Sieber}
const
Clec = 250;
Clac = 200;
begin
If NOT SoundsEnabled then exit;
SoundOff (1); SoundOn (Clec, 1, 55);
SoundOff (1); SoundOn (Clac, 1, 55);
NoSound;
END;
{ -------------------------------------------------------------------------- }
Procedure CloseWhistle;
{ Original author: Bill Buchanan
Modified by Wolfram Sieber }
Var
Frequency: Integer;
begin
If SoundsEnabled then
For Frequency := 1000 downto 500 do
begin
Delay(1);
Sound(Frequency)
end;
NoSound
end;
{ -------------------------------------------------------------------------- }
Procedure ErrorBeep;
{ Original author: Peter Schuette }
Begin
If NOT SoundsEnabled then exit;
SoundOn(50,1,500);
NoSound;
End;
{ -------------------------------------------------------------------------- }
procedure Explosion;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i: integer;
begin
If NOT SoundsEnabled then exit;
for i:=10 to 240 do
SoundOn (round(500*sin(i * 1)), 1, 1);
nosound;
end;
{ -------------------------------------------------------------------------- }
procedure Explosion2;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i: integer;
begin
If NOT SoundsEnabled then exit;
for i:=1000 downto 200 do
SoundOn(random(i+100), 1, 2);
nosound;
end;
{ -------------------------------------------------------------------------- }
Procedure Falling;
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Var I : Word;
Begin
If NOT SoundsEnabled then exit;
For I := 50 DownTo 20 Do
Begin
SoundOn ( I * 10, 3, 50 );
SoundOff ( 20 );
End;
End;
{ -------------------------------------------------------------------------- }
procedure Falling2;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i: integer;
begin
If NOT SoundsEnabled then exit;
for i:=3000 downto 650 do
SoundOn (i, 1, 1);
nosound;
end;
{ -------------------------------------------------------------------------- }
Procedure Fanfare;
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Begin
If NOT SoundsEnabled then exit;
Bell;
Beep;
Boop;
End;
{ -------------------------------------------------------------------------- }
procedure flak;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
delay(100);
for i:=10 to 550 do
SoundOn (round(1000*sin(i * 2)), 1, 1);
nosound;
end;
{ -------------------------------------------------------------------------- }
procedure Gun;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:= 250 to 400 do
SoundOn (random(4000-10*i)-50, 1, 1);
nosound;
end;
{ -------------------------------------------------------------------------- }
Procedure HiRing;
{ Original author: Bjorn Felten,
modifications Orazio Czerwenka,
modification by Wolfram Sieber }
var i:word;
begin
If NOT SoundsEnabled then exit;
for i:=0 to 6 do
begin
soundon(523,2,50);
soundon(659,2,50);
end;
nosound
end;
{ -------------------------------------------------------------------------- }
procedure Laser;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:= 0 to 500 do begin
Sound (random(5500-10*i)-50); {SoundOn is too slow}
Delay (1); {to be used in this case}
end;
nosound;
end;
{ -------------------------------------------------------------------------- }
Procedure LoRing;
{ Original author: Bjorn Felten,
modifications Orazio Czerwenka,
modification by Wolfram Sieber }
var i:word;
begin
If NOT SoundsEnabled then exit;
for i:=0 to 6 do
begin
soundon(523,1,50);
soundon(659,1,50);
end;
nosound
end;
{ -------------------------------------------------------------------------- }
Procedure MorseCode;
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Var I : Word;
Begin
If NOT SoundsEnabled then exit;
For I := 1 To 10 Do
Begin
SoundOn ( 600, 2, 100 );
SoundOff ( 30 + Random (200) );
End;
End;
{ -------------------------------------------------------------------------- }
procedure MP;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:= 250 to 290 do
SoundOn (random(10*i)-60, 1, 1);
nosound;
delay(10);
end;
{ -------------------------------------------------------------------------- }
procedure Mystic;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:= 800 to 2000 do
SoundOn (random(3*5000-4*10*i)-50, 1, 3);
nosound;
end;
{ -------------------------------------------------------------------------- }
procedure Mystic2;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:= 800 to 2000 do begin
SoundOn (random(3*5000-4*10*i)-50, 1, 2);
SoundOn (5500-(i), 1, 1);
end;
nosound;
delay(50);
{for i:=10 to 250 do begin
SoundOn (random(500+i*2)+500, 1, 2);
end;}
for i:=1000*2 downto 200*2 do
SoundOn (random(i div (2+ i div 10000) +100), 1, 2);
nosound;
end;
{ -------------------------------------------------------------------------- }
Procedure Mystic3;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i,x: Integer;
begin
If NOT SoundsEnabled then exit;
i:=30;
x:=30;
repeat
SoundOn (i, 1, 1);
SoundOn (x, 1, 2);
inc(i,2);
inc(x,4);
until (x>5000) {or (keypressed)};
Nosound;
end;
{ -------------------------------------------------------------------------- }
Procedure Mystic4;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i,x: Integer;
begin
If NOT SoundsEnabled then exit;
i:=30;
x:=30;
repeat
SoundOn (i, 1, 1); Nosound;
SoundOn (x, 1, 2); Nosound;
inc(i,2);
inc(x,4);
until (x>5000) {or (keypressed)};
Nosound;
end;
{ -------------------------------------------------------------------------- }
procedure Mystic5;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i: integer;
begin
If NOT SoundsEnabled then exit;
for i:=500 to 2700 do
SoundOn (random(1000)+2*i-500, 1, 1);
nosound;
end;
{ -------------------------------------------------------------------------- }
procedure Noname1;
{Original author: Wolfram Sieber}
var
i : word;
begin
If NOT SoundsEnabled then exit;
for i:=1 to 17 do begin
SoundOn (i*100, 1, 13);
NoSound;
SoundOn (1500, 1, 13);
NoSound;
end;
END;
{ -------------------------------------------------------------------------- }
procedure Noname2;
{Original author: Wolfram Sieber}
var
i : word;
begin
If NOT SoundsEnabled then exit;
for i:=200 to 2500 do begin
SoundOn (500, 1, 1);
NoSound;
SoundOn (i, 1, 1);
end;
nosound
END;
{ -------------------------------------------------------------------------- }
procedure Noname3;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:=0 to 1000 do
SoundOn(i*i, 1, 1);
nosound;
end;
{ -------------------------------------------------------------------------- }
procedure Noname4;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:=0 to 1000 do
SoundOn (i mod 100, 1, 1);
nosound;
end;
{ -------------------------------------------------------------------------- }
procedure Noname5;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i,a:integer;
begin
If NOT SoundsEnabled then exit;
for i:=0 to 10 do begin
a:=a+500;
SoundOn (a, 1, 10);
end;
nosound;
end;
{ -------------------------------------------------------------------------- }
procedure Noname6;
{ Original author: Christian Clemens
Modified by Wolfram Sieber }
var i,c : byte;
hz : word;
begin
If NOT SoundsEnabled then exit;
for c:=1 to 3 do
for i:=1 to 100 do
begin
hz := i*180+100;
SoundOn ( hz, 1, 5);
nosound;
end;
end;
{ -------------------------------------------------------------------------- }
Procedure Nuke;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:= 0 to 5000 do begin
nosound;
SoundOn (random(50+i)-50, 1, 3);
end;
nosound;
end;
{ -------------------------------------------------------------------------- }
Procedure OpenWhistle;
{ Original author: Bill Buchanan
Modified by Wolfram Sieber }
Var
Frequency : Integer;
begin
If NOT SoundsEnabled then exit;
For Frequency := 500 to 1000 do
begin
Delay(1);
Sound(Frequency)
end;
NoSound
end;
{ -------------------------------------------------------------------------- }
procedure Ploing (step : byte);
{Original author: Wolfram Sieber}
var {Fine "Step"s: 10..2}
i : byte;
begin
If NOT SoundsEnabled then exit;
For i:=1 to 100 do begin
SoundOn (i*10, 1, Step);
NoSound;
end;
END;
{ -------------------------------------------------------------------------- }
Procedure Rain;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
begin
If NOT SoundsEnabled then exit;
SoundOn (Random(30)+20, 1, 3);
SoundOff (Random(200));
end;
{ -------------------------------------------------------------------------- }
procedure RandomSound;
{Original author: Wolfram Sieber}
var
i : byte;
begin
If NOT SoundsEnabled then exit;
for i:=1 to 24 do begin
SoundOn ((random (3)+1)*222, 1, 10);
SoundOff (75);
end
END;
{ -------------------------------------------------------------------------- }
procedure SinusBeep;
{ Original author: Pawel Ostapczuk
Modified by Wolfram Sieber }
var i:integer;
begin
If NOT SoundsEnabled then exit;
for i:= 0 to 5 do
SoundOn (round(2000*sin(1000*i))-100, 1, 20);
nosound;
end;
{ -------------------------------------------------------------------------- }
procedure StartingCar;
{Original author: Wolfram Sieber}
var
i : byte;
begin
If NOT SoundsEnabled then exit;
for i:=30 to 120 do begin
SoundOn (i, 1, 50);
nosound
end;
END;
{ -------------------------------------------------------------------------- }
procedure TootTootToot;
{Original author: Wolfram Sieber}
const
TootDelay = 34;
var
i : byte;
begin
If NOT SoundsEnabled then exit;
for i:=1 to 3 do begin
SoundOn (444, 1, TootDelay);
SoundOff (TootDelay)
end
END;
{ -------------------------------------------------------------------------- }
Procedure Warning;
{ Original author: Christian Clemens
Modified by Wolfram Sieber }
Var X : Byte;
Begin
If NOT SoundsEnabled then exit;
For X := 1 To 3 Do
Begin
Sound ( 125 ); Delay ( 50 ); NoSound;
Delay ( 25 );
End;
End;
{ -------------------------------------------------------------------------- }
Procedure WindowsBeep;
{ Original author: Max Maischein
Modified by Wolfram Sieber }
Begin
If NOT SoundsEnabled then exit;
SoundOn( 860,2,30 );
SoundOn( 660,2,15 );
NoSound;
End;
{ -------------------------------------------------------------------------- }
procedure WrongSequence;
{Original author: Wolfram Sieber}
var
Note : byte;
Octave : array [1..7] of byte;
begin
If NOT SoundsEnabled then exit;
Octave [1] := 131; {instead of normally 130.81 Hz}
Octave [2] := 147; {instead of normally 146.83 Hz}
Octave [3] := 165; {instead of normally 164.81 Hz}
Octave [4] := 175; {instead of normally 174.61 Hz}
Octave [6] := 196;
Octave [5] := 220;
Octave [7] := 247; {instead of normally 246.94 Hz}
for Note := 1 to 7 do begin
SoundOn (round (Octave [Note]), 1, 50);
SoundOff (30);
end;
END;
{ -------------------------------------------------------------------------- }
Procedure Zap( Key : Word );
{ Original author: Max Maischein
Modified by Wolfram Sieber }
VAR I,J,K,L : Word;
Begin
If NOT SoundsEnabled then exit;
For I := 1 To 11 Do
Begin
J := 1 * 23 + ( 51 - Random ( Key ) );
For K := 1 To 5 Do
Begin
For L := 1 To 37 - K * 2 Do Sound ( ( L+J+K*2)*3 Div 2 );
Delay ( Key );
Inc ( J , 31 );
End;
End;
NoSound ;
End;
{ -------------------------------------------------------------------------- }
procedure Zip1;
{Original author: Wolfram Sieber}
var
i : byte;
begin
If NOT SoundsEnabled then exit;
for i:=1 to 150 do
SoundOn (i*100, 1, 1);
nosound
END;
{ -------------------------------------------------------------------------- }
procedure Zip2;
{Original author: Wolfram Sieber}
var
i : byte;
begin
If NOT SoundsEnabled then exit;
for i:=1 to 150 do begin
SoundOn (i*100, 1, 1);
nosound;
end;
END;
{-sound effects------------------------------------------------------------9-}
(* procedure InitFSPEAKER;
begin
EnableSpeaker;
end;
{$IFOPT O-}
Begin
InitFSPEAKER;
{$ENDIF} *)
End.